home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / osr5 / devtools / dejagnu-971222 / usr / local / share / dejagnu / debugger.exp < prev    next >
Encoding:
Text File  |  1998-03-22  |  5.2 KB  |  245 lines
  1. # Copyright (C) 92, 93, 94, 95, 1996 Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2 of the License, or
  6. # (at your option) any later version.
  7. # 
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12. # 
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  
  16.  
  17. # Please email any bugs, comments, and/or additions to this file to:
  18. # bug-dejagnu@prep.ai.mit.edu
  19.  
  20. # This file was written by Rob Savoye. (rob@cygnus.com)
  21.  
  22. #
  23. # Dump the values of a shell expression representing variable
  24. # names.
  25. proc dumpvars { args } {
  26.     uplevel 1 [list foreach i [uplevel 1 "info vars $args"] {
  27.     if { [catch "array names $i" names ] } {
  28.         eval "puts \"${i} = \$${i}\""
  29.     } else {
  30.         foreach k $names {
  31.         eval "puts \"$i\($k\) = \$$i\($k\)\""
  32.         }
  33.     }
  34.     }
  35.        ]
  36. }
  37.  
  38. #
  39. # dump the values of a shell expression representing variable
  40. # names.
  41. proc dumplocals { args } {
  42.     uplevel 1 [list foreach i [uplevel 1 "info locals $args"] {
  43.     if { [catch "array names $i" names ] } {
  44.         eval "puts \"${i} = \$${i}\""
  45.     } else {
  46.         foreach k $names {
  47.         eval "puts \"$i\($k\) = \$$i\($k\)\""
  48.         }
  49.     }
  50.     }
  51.        ]
  52. }
  53. #
  54. # Dump the body of procedures specified by a regexp.
  55. #
  56. proc dumprocs { args } {
  57.     foreach i [info procs $args] {
  58.     puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}"
  59.     }
  60. }
  61.  
  62. #
  63. # Dump all the current watchpoints
  64. #
  65. proc dumpwatch { args } {
  66.     foreach i [uplevel 1 "info vars $args"] {
  67.     set tmp ""
  68.     if { [catch "uplevel 1 array name $i" names] } {
  69.         set tmp [uplevel 1 trace vinfo $i]
  70.         if ![string match "" $tmp] {
  71.         puts "$i $tmp"
  72.         }
  73.     } else {
  74.         foreach k $names {
  75.         set tmp [uplevel 1 trace vinfo [set i]($k)]
  76.         if ![string match "" $tmp] {
  77.             puts "[set i]($k) = $tmp"
  78.         }
  79.         }
  80.     }
  81.     }
  82. }
  83.  
  84. #
  85. # Trap a watchpoint for an array
  86. #
  87. proc watcharray { element type} {
  88.     upvar [set array]($element) avar
  89.     case $type {
  90.     "w" { puts "New value of [set array]($element) is $avar" }
  91.     "r" { puts "[set array]($element) (= $avar) was just read" }
  92.     "u" { puts "[set array]($element) (= $avar) was just unset" }
  93.     }
  94. }
  95.  
  96. proc watchvar { v type } {
  97.     upvar $v var
  98.     case $type {
  99.     "w" { puts "New value of $v is $var" }
  100.     "r" { puts "$v (=$var) was just read" }
  101.     "u" { puts "$v (=$var) was just unset" }
  102.     }
  103. }
  104.  
  105. #
  106. # Watch when a variable is written
  107. #
  108. proc watchunset { arg } {
  109.     if { [catch "uplevel 1 array name $arg" names ] } {
  110.     if ![uplevel 1 info exists $arg] {
  111.         puts stderr "$arg does not exist"
  112.         return
  113.     }
  114.     uplevel 1 trace variable $arg u watchvar
  115.     } else {
  116.     foreach k $names {
  117.         if ![uplevel 1 info exists $arg] {
  118.         puts stderr "$arg does not exist"
  119.         return
  120.         }
  121.         uplevel 1 trace variable [set arg]($k) u watcharray
  122.     }
  123.     }
  124. }
  125.  
  126. #
  127. # Watch when a variable is written
  128. #
  129. proc watchwrite { arg } {
  130.     if { [catch "uplevel 1 array name $arg" names ] } {
  131.     if ![uplevel 1 info exists $arg] {
  132.         puts stderr "$arg does not exist"
  133.         return
  134.     }
  135.     uplevel 1 trace variable $arg w watchvar
  136.     } else {
  137.     foreach k $names {
  138.         if ![uplevel 1 info exists $arg] {
  139.         puts stderr "$arg does not exist"
  140.         return
  141.         }
  142.         uplevel 1 trace variable [set arg]($k) w watcharray
  143.     }
  144.     }
  145. }
  146.  
  147. #
  148. # Watch when a variable is read
  149. #
  150. proc watchread { arg } {
  151.     if { [catch "uplevel 1 array name $arg" names ] } {
  152.     if ![uplevel 1 info exists $arg] {
  153.         puts stderr "$arg does not exist"
  154.         return
  155.     }
  156.     uplevel 1 trace variable $arg r watchvar
  157.     } else {
  158.     foreach k $names {
  159.         if ![uplevel 1 info exists $arg] {
  160.         puts stderr "$arg does not exist"
  161.         return
  162.         }
  163.         uplevel 1 trace variable [set arg]($k) r watcharray
  164.     }
  165.     }
  166. }
  167.  
  168. #
  169. # Delete a watch point
  170. #
  171. proc watchdel { args } {
  172.     foreach i [uplevel 1 "info vars $args"] {
  173.     set tmp ""
  174.     if { [catch "uplevel 1 array name $i" names] } {
  175.         catch "uplevel 1 trace vdelete $i w watchvar"
  176.         catch "uplevel 1 trace vdelete $i r watchvar"
  177.         catch "uplevel 1 trace vdelete $i u watchvar"
  178.     } else {
  179.         foreach k $names {
  180.         catch "uplevel 1 trace vdelete [set i]($k) w watcharray"
  181.         catch "uplevel 1 trace vdelete [set i]($k) r watcharray"
  182.         catch "uplevel 1 trace vdelete [set i]($k) u watcharray"
  183.         }
  184.     }
  185.     }
  186. }
  187.  
  188. #
  189. # This file creates GDB style commands for the Tcl debugger
  190. #
  191. proc print { var } {
  192.     puts "$var"
  193. }
  194.  
  195. proc quit { } {
  196.     log_and_exit;
  197. }
  198.  
  199. proc bt { } {
  200.     puts "[w]"
  201. }
  202.  
  203. #
  204. # create some stub procedures since we can't alias the command names
  205. #
  206. proc dp { args } {
  207.   uplevel 1 dumprocs $args
  208. }
  209.  
  210. proc dv { args } {
  211.   uplevel 1 dumpvars $args
  212. }
  213.  
  214. proc dl { args } {
  215.   uplevel 1 dumplocals $args
  216. }
  217.  
  218. proc dw { args } {
  219.     uplevel 1 dumpwatch $args
  220. }
  221.  
  222. proc q { } {
  223.     quit
  224. }
  225.  
  226. proc p { args } {
  227.     uplevel 1 print $args
  228. }
  229.  
  230. proc wu { args } {
  231.     uplevel 1 watchunset $args
  232. }
  233.  
  234. proc ww { args } {
  235.     uplevel 1 watchwrite $args
  236. }
  237.  
  238. proc wr { args } {
  239.     uplevel 1 watchread $args
  240. }
  241.  
  242. proc wd { args } {
  243.     uplevel 1 watchdel $args
  244. }
  245.